home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
xlibpas2.zip
/
XLIBDEMO.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1994-06-12
|
18KB
|
516 lines
{ VERY QUICK AND ULTRA-DIRTY DEMO USING XLIB
Simple Demo of MODE X Split screen and panning
Compile using Borland/Turbo Pascal 6.0/7.0 }
{$IFDEF DPMI}
{$C FIXED PRELOAD PERMANENT}
{$ENDIF}
Program Xlibdemo;
Uses
Crt, XLib2, xbm2;
Const
MaxObjects = 10;
ObjectCount : integer = 0;
bm : array[0..193] of byte =
(4,12,
2,2,2,2,2,1,1,1,2,1,1,1,2,3,3,1,
2,0,0,3,2,0,0,3,2,0,0,3,2,0,0,3,
2,3,3,1,2,1,1,1,2,1,1,1,2,2,2,2,
2,2,2,2,1,1,1,1,1,1,1,1,1,3,3,1,
1,0,0,1,1,0,0,1,1,0,0,1,1,0,0,1,
1,3,3,1,1,1,1,1,1,1,1,1,2,2,2,2,
2,2,2,2,1,1,1,1,1,1,1,1,1,3,3,1,
1,0,0,1,1,0,0,1,1,0,0,1,1,0,0,1,
1,3,3,1,1,1,1,1,1,1,1,1,2,2,2,2,
2,2,2,2,1,1,1,2,1,1,1,2,1,3,3,2,
3,0,0,2,3,0,0,2,3,0,0,2,3,0,0,2,
1,3,3,2,1,1,1,2,1,1,1,2,2,2,2,2 );
bm2 : array[0..193] of byte =
(4,12,
2,2,2,2,2,4,4,4,2,4,4,4,2,2,2,4,
2,0,0,2,2,0,0,2,2,0,0,2,2,0,0,2,
2,2,2,4,2,4,4,4,2,4,4,4,2,2,2,2,
2,2,2,2,4,4,4,4,4,4,4,4,4,2,2,4,
4,0,0,4,4,0,0,4,4,0,0,4,4,0,0,4,
4,2,2,4,4,4,4,4,4,4,4,4,2,2,2,2,
2,2,2,2,4,4,4,4,4,4,4,4,4,2,2,4,
4,0,0,4,4,0,0,4,4,0,0,4,4,0,0,4,
4,2,2,4,4,4,4,4,4,4,4,4,2,2,2,2,
2,2,2,2,4,4,4,2,4,4,4,2,4,2,2,2,
2,0,0,2,2,0,0,2,2,0,0,2,2,0,0,2,
4,2,2,2,4,4,4,2,4,4,4,2,2,2,2,2);
palscrolldir : integer = 1;
textwindowx : integer = 0;
textwindowy : integer = 0;
Type
AnimatedObject = record
X,Y,Width,Height,XDir,YDir,XOtherPage,YOtherPage : integer;
Image, bg, bgOtherPage : pointer;
end;
Var
objects : array[0..MaxObjects] of AnimatedObject;
userfnt1, pal, pal2, SaveExitProc : pointer;
xpos : integer;
procedure initobject( x, y, width, height, xdir, ydir : integer;
var image : pointer );
begin
objects[objectcount].X := x;
objects[objectcount].XOtherPage := x;
objects[objectcount].Y := y;
objects[objectcount].YOtherPage := y;
objects[objectcount].Width := width;
objects[objectcount].Height := height;
objects[objectcount].XDir := xdir;
objects[objectcount].YDir := ydir;
objects[objectcount].Image := image;
GetMem( objects[objectcount].bg, 4*width*height+20);
GetMem( objects[objectcount].bgOtherPage, 4*width*height+20);
xgetpbm(x,y,width,height,VisiblePageOffs, objects[objectcount].bg^);
xgetpbm(x,y,width,height,HiddenPageOffs, objects[objectcount].bgOtherPage^);
inc(objectcount);
end;
procedure MoveObject( var ObjectToMove : AnimatedObject );
var
X, Y : integer;
cptr : pointer;
begin
X := ObjectToMove.X + ObjectToMove.XDir;
Y := ObjectToMove.Y + ObjectToMove.YDir;
if (X < 0) or (X > (ScrnLogicalPixelWidth-(ObjectToMove.Width shl 2))) then
begin
ObjectToMove.XDir := -ObjectToMove.XDir;
X := ObjectToMove.X + ObjectToMove.XDir;
end;
if (Y < 0) or (Y > (ScrnLogicalHeight-ObjectToMove.Height)) then
begin
ObjectToMove.YDir := -ObjectToMove.YDir;
Y := ObjectToMove.Y + ObjectToMove.YDir;
end;
ObjectToMove.XOtherPage := ObjectToMove.X;
ObjectToMove.YOtherPage := ObjectToMove.Y;
ObjectToMove.X := X;
ObjectToMove.Y := Y;
cptr := ObjectToMove.bg;
ObjectToMove.bg := ObjectToMove.bgOtherPage;
ObjectToMove.bgOtherPage := cptr;
end;
procedure animate;
var
i : integer;
begin
for i:=objectcount-1 downto 0 do
xputpbm(objects[i].XOtherPage,objects[i].YOtherPage,
HiddenPageOffs,objects[i].bgOtherPage^);
for i:=0 to objectcount-1 do
begin
MoveObject(objects[i]);
xgetpbm(objects[i].X,objects[i].Y,
objects[i].Width,objects[i].Height,HiddenPageOffs,
objects[i].bg^);
xputmaskedpbm(objects[i].X,objects[i].Y,HiddenPageOffs,
objects[i].Image^);
end;
end;
procedure clearobjects;
var
i : integer;
begin
for i:=objectcount-1 downto 0 do
xputpbm(objects[i].XOtherPage,objects[i].YOtherPage,
HiddenPageOffs,objects[i].bgOtherPage^);
end;
procedure textwindow( Margin : integer );
var
x0, y0, x1, y1 : integer;
begin
x0 := Margin;
y0 := Margin;
x1 := ScrnPhysicalPixelWidth-Margin;
y1 := ScrnPhysicalHeight-Margin;
xrectfill(x0, y0, x1,y1,VisiblePageOffs,1);
xline(x0,y0,x1,y0,2,VisiblePageOffs);
xline(x0,y1,x1,y1,2,VisiblePageOffs);
xline(x0,y0,x0,y1,2,VisiblePageOffs);
xline(x1,y0,x1,y1,2,VisiblePageOffs);
xline(x0+2,y0+2,x1-2,y0+2,2,VisiblePageOffs);
xline(x0+2,y1-2,x1-2,y1-2,2,VisiblePageOffs);
xline(x0+2,y0+2,x0+2,y1-2,2,VisiblePageOffs);
xline(x1-2,y0+2,x1-2,y1-2,2,VisiblePageOffs);
textwindowx:=x0;
textwindowy:=y0;
end;
procedure waitforkeypress;
begin
xshowmouse;
while keypressed do readkey;
while MouseButtonStatus=LeftPressed do;
palscrolldir := 1-palscrolldir;
while (not keypressed) and (MouseButtonStatus<>LeftPressed) do
begin
xrotpalstruc(pal^,palscrolldir);
{Notice that there is no need to freeze and update the mouse if the
vsync handler is installed while just updating the palette, because the
DAC is changed before the mouse handler is called}
{$IFDEF DPMI}
mousefrozen := 1;
{$ENDIF}
xputpalstruc(pal^);
{$IFDEF DPMI}
xupdatemouse;
{$ENDIF}
end;
while keypressed do readkey;
while MouseButtonStatus=LeftPressed do;
end;
procedure quit; far;
begin
{$IFDEF DPMI}
xremovevsynchandler;
{$ENDIF}
xmouseremove;
textmode(co80+font8x8);
ExitProc := SaveExitProc;
end;
procedure intro1;
begin
xsetrgb(1,40,40,40);
xsetrgb(2,63,63,0);
xsetrgb(3,63,0,0);
xsetrgb(4,0,63,0);
xsetrgb(5,0,0,63);
xsetrgb(6,0,0,28);
xsetrgb(7,0,28,0);
xsetrgb(8,28,0,0);
xsetrgb(9,0,0,38);
textwindow(20);
xsetfont(1);
xpos := xcentre(180,textwindowy+4,VisiblePageOffs,6,'XLibPas Version 2.0');
xprintf(xpos-1,textwindowy+3,VisiblePageOffs,2,'XLibPas Version 2.0');
xsetfont(0);
xpos := xcentre(180,168,VisiblePageOffs,6,'Press any key to continue');
xprintf(xpos-1,167,VisiblePageOffs,2,'Press any key to continue');
end;
procedure subsequentpage;
begin
xhidemouse;
textwindow(20);
xsetfont(1);
xpos := xcentre(180,textwindowy+4,VisiblePageOffs,6,'XLibPas Version 2.0');
xprintf(xpos-1,textwindowy+3,VisiblePageOffs,2,'XLibPas Version 2.0');
xsetfont(0);
xpos := xcentre(180,168,VisiblePageOffs,6,'Press any key to continue');
xprintf(xpos-1,167,VisiblePageOffs,2,'Press any key to continue');
end;
procedure loaduserfonts;
var
f : File;
begin
assign(f,'fonts\var6x8.fnt');
reset(f,1);
blockread( f, userfnt1^, filesize(f) );
close(f);
xregisteruserfont(userfnt1^);
end;
procedure main;
var
i, j, xinc, yinc, Margin : integer;
ch : char;
a : byte;
currx, curry : word;
x0,x1,x2,y0,y1,y2 : integer;
pt : pointer;
begin
GetMem(pal,256*3);
GetMem(pal2,256*3);
GetMem(userfnt1,256*16+4);
currx := 0;
curry := 0;
xtextmode;
xsetmode(XMODE360x200,500);
{$IFNDEF DPMI}
xinstallvsynchandler(1);
{$ENDIF}
xsetsplitscreen(ScrnPhysicalHeight-61);
xsetdoublebuffer(220);
xhidesplitscreen;
xtextinit;
xmouseinit;
xmousewindow(0,0,359,199);
mousecolor := 2;
for j:=0 to ScrnPhysicalHeight-1 do
xline(0,j,ScrnLogicalPixelWidth,j,16+(j mod 239),VisiblePageOffs);
xgetpalstruc(pal^,240,16);
loaduserfonts;
intro1;
xsetfont(2);
xhidemouse;
xprintf(textwindowx+5,50 ,VisiblePageOffs,9, ' Hi, folks. This is yet another FREEWARE Mode X graphics');
xprintf(textwindowx+5,50+8 ,VisiblePageOffs,9, ' library. It is by no means complete, but I believe it');
xprintf(textwindowx+5,50+16,VisiblePageOffs,9, ' contains a rich enough set of functions to achieve its');
xprintf(textwindowx+5,50+24,VisiblePageOffs,9, ' design goal : a game development oriented library for');
xprintf(textwindowx+5,50+32,VisiblePageOffs,9, ' Borland TP/BP programmers.');
xprintf(textwindowx+5,50+48,VisiblePageOffs,9, ' This library comes with BP/TP sources.');
xprintf(textwindowx+5,50+56,VisiblePageOffs,9, ' It was inspired by the DDJ Graphics column and many');
xprintf(textwindowx+5,50+64,VisiblePageOffs,9, ' INTERNET and USENET authors who, unlike the majority of');
xprintf(textwindowx+5,50+72,VisiblePageOffs,9, ' programmers (you know who you are!), willingly share');
xprintf(textwindowx+5,50+80,VisiblePageOffs,9, ' their code and ideas with others.');